
unit DIrr.VCLApp;


interface

uses
  VCL.Forms, WinApi.Windows, WinApi.Messages,
  DIrr, DIrr.Irr, DIrr.Video, DIrr.Scene, DIrr.GUI, DIrr.Color, DIrr.Types,
  DIrr.Base;

type
  TGameLogic = class abstract
  public
    function Run(CurrentTime, RealTime: Cardinal): Boolean; virtual;
  end;


  TApplicationHelper = class helper for TApplication
  private class var
    FGameLogic: TGameLogic;
  public
    function DoProcMessage(var Msg: TMsg): Boolean;
    procedure RunEx;
    function InitDIrr(const WndHandle: HWND; GameLogic: TGameLogic = nil;
      Width: Integer = 0; Height: Integer = 0): Boolean;
  end;

var
  IrrDevice: TIrrlichtDevice;
  IrrDriver: TVideoDriver;
  IrrSmgr: TSceneManager;
  IrrGUI: TGUIEnvironment;
  IrrTimer: TIrrTimer;

implementation

uses
  Dirr.Consts, DIrr.Rect, DIrr.Structs;

{ TApplicationHelper }

function TApplicationHelper.DoProcMessage(var Msg: TMsg): Boolean;
var
  Handled: Boolean;
  Unicode: Boolean;
  MsgExists: Boolean;
begin
  Result := False;
  if PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE) then
  begin
    Unicode := (Msg.hwnd = 0) or IsWindowUnicode(Msg.hwnd);
    if Unicode then
      MsgExists := PeekMessageW(Msg, 0, 0, 0, PM_REMOVE)
    else
      MsgExists := PeekMessageA(Msg, 0, 0, 0, PM_REMOVE);

    if MsgExists then
    begin
      Result := True;
      if Msg.Message <> WM_QUIT then
      begin
        Handled := False;
        if Assigned(OnMessage) then OnMessage(Msg, Handled);
        if not IsPreProcessMessage(Msg) and not IsHintMsg(Msg) and
          not Handled and not IsMDIMsg(Msg) and
          not IsKeyMsg(Msg) and not IsDlgMsg(Msg) then
        begin
          TranslateMessage(Msg);
          if Unicode then
            DispatchMessageW(Msg)
          else
            DispatchMessageA(Msg);
        end;
      end
      else
      begin
  {$IF DEFINED(CLR)}
        if Assigned(OnShutDown) then OnShutDown(self);
        DoneApplication;
  {$ENDIF}
        //FTerminate := True;
      end;
    end;
  end;
end;

function TApplicationHelper.InitDIrr(const WndHandle: HWND; GameLogic: TGameLogic;
  Width, Height: Integer): Boolean;
var
  Param: SIrrlichtCreationParameters;
  WinRect: TRect;
begin
  if (Width and Height = 0) then
  begin
    GetClientRect(WndHandle, WinRect);
    Width := WinRect.Width;
    Height := WinRect.Height;
  end;

  FGameLogic := GameLogic;

  Param.Init;
  Param.WindowSize.Width := Width;
  Param.WindowSize.Height := Height;
  Param.DriverType := EDT_DIRECT3D9;
  Param.WindowId := Pointer(WndHandle);


  IrrDevice := CreateDevice(Param);
  if Assigned(IrrDevice) then
  begin
    IrrSmgr := IrrDevice.GetSceneManager;
    IrrDriver := IrrDevice.GetVideoDriver;
    IrrGUI := IrrDevice.GetGUIEnvironment;
    IrrTimer := IrrDevice.GetTimer;

    Result := True;
  end
  else
  begin
    Result := False;
  end;
end;

procedure TApplicationHelper.RunEx;
var
  Msg: TMsg;
begin
  if Assigned(IrrDevice) then
  begin
    if MainForm <> nil then
    begin
      if ShowMainForm then
        MainForm.Show;
    end;

    while IrrDevice.Run do
    begin
      if Assigned(FGameLogic) then
      begin
        if not FGameLogic.Run(IrrTimer.GetTime, IrrTimer.GetRealTime) then
          continue;
      end;

      IrrDriver.BeginScene(True, True, IrrColor(83, 83, 255));

      IrrSmgr.DrawAll;
      IrrGUI.DrawAll;

      IrrDriver.EndScene;

      Msg.hwnd := Application.Handle;
      Application.DoProcMessage(Msg);
    end;

    IrrDevice.CloseDevice;
    IrrDevice.Drop;
    IrrDevice := nil;
  end
  else
  begin
    Application.Run;
  end;
end;

{ TGameLogic }

function TGameLogic.Run(CurrentTime, RealTime: Cardinal): Boolean;
begin
  Result := True;
end;

initialization

finalization

end.
